{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedLists #-}

-- 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.Client
  ( FederatorClientEnv (..),
    FederatorClientVersionedEnv (..),
    unversionedEnv,
    FederatorClient,
    runFederatorClient,
    runVersionedFederatorClient,
    runFederatorClientToCodensity,
    runVersionedFederatorClientToCodensity,
    getNegotiatedVersion,
    performHTTP2Request,
    consumeStreamingResponseWith,
    streamingResponseStrictBody,
    headersFromTable,
  )
where

import Control.Concurrent.Async
import Control.Exception qualified as E
import Control.Monad.Catch
import Control.Monad.Codensity
import Control.Monad.Except
import Control.Monad.Trans.Maybe
import Data.Aeson qualified as Aeson
import Data.Bifunctor (first)
import Data.ByteString qualified as BS
import Data.ByteString.Builder
import Data.ByteString.Conversion (toByteString')
import Data.ByteString.Lazy qualified as LBS
import Data.Domain
import Data.Id
import Data.Sequence (pattern (:<|))
import Data.Sequence qualified as Seq
import Data.Set qualified as Set
import Data.Text.Encoding qualified as Text
import Data.Text.Encoding.Error qualified as Text
import Data.Text.Lazy.Encoding qualified as LText
import HTTP2.Client.Manager (Http2Manager)
import HTTP2.Client.Manager qualified as H2Manager
import Imports
import Network.HPACK qualified as HTTP2
import Network.HPACK.Token qualified as HTTP2
import Network.HTTP.Media qualified as HTTP
import Network.HTTP.Types qualified as HTTP
import Network.HTTP2.Client qualified as HTTP2
import Network.Wai.Utilities.Error qualified as Wai
import OpenSSL.Session qualified as SSL
import Servant.Client
import Servant.Client.Core
import Servant.Types.SourceT
import Util.Options (Endpoint (..))
import Wire.API.Federation.Component
import Wire.API.Federation.Domain (originDomainHeaderName)
import Wire.API.Federation.Error
import Wire.API.Federation.Version
import Wire.API.VersionInfo

data FederatorClientEnv = FederatorClientEnv
  { FederatorClientEnv -> Domain
ceOriginDomain :: Domain,
    FederatorClientEnv -> Domain
ceTargetDomain :: Domain,
    FederatorClientEnv -> Endpoint
ceFederator :: Endpoint,
    FederatorClientEnv -> Http2Manager
ceHttp2Manager :: Http2Manager,
    FederatorClientEnv -> RequestId
ceOriginRequestId :: RequestId
  }

data FederatorClientVersionedEnv = FederatorClientVersionedEnv
  { FederatorClientVersionedEnv -> FederatorClientEnv
cveEnv :: FederatorClientEnv,
    FederatorClientVersionedEnv -> Maybe Version
cveVersion :: Maybe Version
  }

unversionedEnv :: FederatorClientEnv -> FederatorClientVersionedEnv
unversionedEnv :: FederatorClientEnv -> FederatorClientVersionedEnv
unversionedEnv FederatorClientEnv
env = FederatorClientEnv -> Maybe Version -> FederatorClientVersionedEnv
FederatorClientVersionedEnv FederatorClientEnv
env Maybe Version
forall a. Maybe a
Nothing

-- | A request to a remote backend. The API version of the remote backend is in
-- the environment. The 'MaybeT' layer is used to match endpoint versions (via
-- the 'Alternative' and 'VersionedMonad' instances).
newtype FederatorClient (c :: Component) a = FederatorClient
  { forall (c :: Component) a.
FederatorClient c a
-> MaybeT
     (ReaderT
        FederatorClientVersionedEnv
        (ExceptT FederatorClientError (Codensity IO)))
     a
unFederatorClient ::
      MaybeT
        ( ReaderT
            FederatorClientVersionedEnv
            (ExceptT FederatorClientError (Codensity IO))
        )
        a
  }
  deriving newtype
    ( (forall a b.
 (a -> b) -> FederatorClient c a -> FederatorClient c b)
-> (forall a b. a -> FederatorClient c b -> FederatorClient c a)
-> Functor (FederatorClient c)
forall a b. a -> FederatorClient c b -> FederatorClient c a
forall a b. (a -> b) -> FederatorClient c a -> FederatorClient c b
forall (c :: Component) a b.
a -> FederatorClient c b -> FederatorClient c a
forall (c :: Component) a b.
(a -> b) -> FederatorClient c a -> FederatorClient c b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (c :: Component) a b.
(a -> b) -> FederatorClient c a -> FederatorClient c b
fmap :: forall a b. (a -> b) -> FederatorClient c a -> FederatorClient c b
$c<$ :: forall (c :: Component) a b.
a -> FederatorClient c b -> FederatorClient c a
<$ :: forall a b. a -> FederatorClient c b -> FederatorClient c a
Functor,
      Applicative (FederatorClient c)
Applicative (FederatorClient c) =>
(forall a. FederatorClient c a)
-> (forall a.
    FederatorClient c a -> FederatorClient c a -> FederatorClient c a)
-> (forall a. FederatorClient c a -> FederatorClient c [a])
-> (forall a. FederatorClient c a -> FederatorClient c [a])
-> Alternative (FederatorClient c)
forall a. FederatorClient c a
forall a. FederatorClient c a -> FederatorClient c [a]
forall a.
FederatorClient c a -> FederatorClient c a -> FederatorClient c a
forall (c :: Component). Applicative (FederatorClient c)
forall (c :: Component) a. FederatorClient c a
forall (c :: Component) a.
FederatorClient c a -> FederatorClient c [a]
forall (c :: Component) a.
FederatorClient c a -> FederatorClient c a -> FederatorClient c a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall (c :: Component) a. FederatorClient c a
empty :: forall a. FederatorClient c a
$c<|> :: forall (c :: Component) a.
FederatorClient c a -> FederatorClient c a -> FederatorClient c a
<|> :: forall a.
FederatorClient c a -> FederatorClient c a -> FederatorClient c a
$csome :: forall (c :: Component) a.
FederatorClient c a -> FederatorClient c [a]
some :: forall a. FederatorClient c a -> FederatorClient c [a]
$cmany :: forall (c :: Component) a.
FederatorClient c a -> FederatorClient c [a]
many :: forall a. FederatorClient c a -> FederatorClient c [a]
Alternative,
      Functor (FederatorClient c)
Functor (FederatorClient c) =>
(forall a. a -> FederatorClient c a)
-> (forall a b.
    FederatorClient c (a -> b)
    -> FederatorClient c a -> FederatorClient c b)
-> (forall a b c.
    (a -> b -> c)
    -> FederatorClient c a
    -> FederatorClient c b
    -> FederatorClient c c)
-> (forall a b.
    FederatorClient c a -> FederatorClient c b -> FederatorClient c b)
-> (forall a b.
    FederatorClient c a -> FederatorClient c b -> FederatorClient c a)
-> Applicative (FederatorClient c)
forall a. a -> FederatorClient c a
forall a b.
FederatorClient c a -> FederatorClient c b -> FederatorClient c a
forall a b.
FederatorClient c a -> FederatorClient c b -> FederatorClient c b
forall a b.
FederatorClient c (a -> b)
-> FederatorClient c a -> FederatorClient c b
forall a b c.
(a -> b -> c)
-> FederatorClient c a
-> FederatorClient c b
-> FederatorClient c c
forall (c :: Component). Functor (FederatorClient c)
forall (c :: Component) a. a -> FederatorClient c a
forall (c :: Component) a b.
FederatorClient c a -> FederatorClient c b -> FederatorClient c a
forall (c :: Component) a b.
FederatorClient c a -> FederatorClient c b -> FederatorClient c b
forall (c :: Component) a b.
FederatorClient c (a -> b)
-> FederatorClient c a -> FederatorClient c b
forall (c :: Component) a b c.
(a -> b -> c)
-> FederatorClient c a
-> FederatorClient c b
-> FederatorClient c c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (c :: Component) a. a -> FederatorClient c a
pure :: forall a. a -> FederatorClient c a
$c<*> :: forall (c :: Component) a b.
FederatorClient c (a -> b)
-> FederatorClient c a -> FederatorClient c b
<*> :: forall a b.
FederatorClient c (a -> b)
-> FederatorClient c a -> FederatorClient c b
$cliftA2 :: forall (c :: Component) a b c.
(a -> b -> c)
-> FederatorClient c a
-> FederatorClient c b
-> FederatorClient c c
liftA2 :: forall a b c.
(a -> b -> c)
-> FederatorClient c a
-> FederatorClient c b
-> FederatorClient c c
$c*> :: forall (c :: Component) a b.
FederatorClient c a -> FederatorClient c b -> FederatorClient c b
*> :: forall a b.
FederatorClient c a -> FederatorClient c b -> FederatorClient c b
$c<* :: forall (c :: Component) a b.
FederatorClient c a -> FederatorClient c b -> FederatorClient c a
<* :: forall a b.
FederatorClient c a -> FederatorClient c b -> FederatorClient c a
Applicative,
      Applicative (FederatorClient c)
Applicative (FederatorClient c) =>
(forall a b.
 FederatorClient c a
 -> (a -> FederatorClient c b) -> FederatorClient c b)
-> (forall a b.
    FederatorClient c a -> FederatorClient c b -> FederatorClient c b)
-> (forall a. a -> FederatorClient c a)
-> Monad (FederatorClient c)
forall a. a -> FederatorClient c a
forall a b.
FederatorClient c a -> FederatorClient c b -> FederatorClient c b
forall a b.
FederatorClient c a
-> (a -> FederatorClient c b) -> FederatorClient c b
forall (c :: Component). Applicative (FederatorClient c)
forall (c :: Component) a. a -> FederatorClient c a
forall (c :: Component) a b.
FederatorClient c a -> FederatorClient c b -> FederatorClient c b
forall (c :: Component) a b.
FederatorClient c a
-> (a -> FederatorClient c b) -> FederatorClient c b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (c :: Component) a b.
FederatorClient c a
-> (a -> FederatorClient c b) -> FederatorClient c b
>>= :: forall a b.
FederatorClient c a
-> (a -> FederatorClient c b) -> FederatorClient c b
$c>> :: forall (c :: Component) a b.
FederatorClient c a -> FederatorClient c b -> FederatorClient c b
>> :: forall a b.
FederatorClient c a -> FederatorClient c b -> FederatorClient c b
$creturn :: forall (c :: Component) a. a -> FederatorClient c a
return :: forall a. a -> FederatorClient c a
Monad,
      MonadReader FederatorClientVersionedEnv,
      MonadError FederatorClientError,
      Monad (FederatorClient c)
Monad (FederatorClient c) =>
(forall a. IO a -> FederatorClient c a)
-> MonadIO (FederatorClient c)
forall a. IO a -> FederatorClient c a
forall (c :: Component). Monad (FederatorClient c)
forall (c :: Component) a. IO a -> FederatorClient c a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall (c :: Component) a. IO a -> FederatorClient c a
liftIO :: forall a. IO a -> FederatorClient c a
MonadIO
    )

instance VersionedMonad Version (FederatorClient c) where
  guardVersion :: (Version -> Bool) -> FederatorClient c ()
guardVersion Version -> Bool
p = do
    Maybe Version
v <- (FederatorClientVersionedEnv -> Maybe Version)
-> FederatorClient c (Maybe Version)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks FederatorClientVersionedEnv -> Maybe Version
cveVersion
    Bool -> FederatorClient c ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> (Version -> Bool) -> Maybe Version -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True Version -> Bool
p Maybe Version
v)

getNegotiatedVersion :: FederatorClient c (Maybe Version)
getNegotiatedVersion :: forall (c :: Component). FederatorClient c (Maybe Version)
getNegotiatedVersion = (FederatorClientVersionedEnv -> Maybe Version)
-> FederatorClient c (Maybe Version)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks FederatorClientVersionedEnv -> Maybe Version
cveVersion

liftCodensity :: Codensity IO a -> FederatorClient c a
liftCodensity :: forall a (c :: Component). Codensity IO a -> FederatorClient c a
liftCodensity = MaybeT
  (ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO)))
  a
-> FederatorClient c a
forall (c :: Component) a.
MaybeT
  (ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO)))
  a
-> FederatorClient c a
FederatorClient (MaybeT
   (ReaderT
      FederatorClientVersionedEnv
      (ExceptT FederatorClientError (Codensity IO)))
   a
 -> FederatorClient c a)
-> (Codensity IO a
    -> MaybeT
         (ReaderT
            FederatorClientVersionedEnv
            (ExceptT FederatorClientError (Codensity IO)))
         a)
-> Codensity IO a
-> FederatorClient c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT
  FederatorClientVersionedEnv
  (ExceptT FederatorClientError (Codensity IO))
  a
-> MaybeT
     (ReaderT
        FederatorClientVersionedEnv
        (ExceptT FederatorClientError (Codensity IO)))
     a
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT
   FederatorClientVersionedEnv
   (ExceptT FederatorClientError (Codensity IO))
   a
 -> MaybeT
      (ReaderT
         FederatorClientVersionedEnv
         (ExceptT FederatorClientError (Codensity IO)))
      a)
-> (Codensity IO a
    -> ReaderT
         FederatorClientVersionedEnv
         (ExceptT FederatorClientError (Codensity IO))
         a)
-> Codensity IO a
-> MaybeT
     (ReaderT
        FederatorClientVersionedEnv
        (ExceptT FederatorClientError (Codensity IO)))
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT FederatorClientError (Codensity IO) a
-> ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO))
     a
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT FederatorClientVersionedEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT FederatorClientError (Codensity IO) a
 -> ReaderT
      FederatorClientVersionedEnv
      (ExceptT FederatorClientError (Codensity IO))
      a)
-> (Codensity IO a
    -> ExceptT FederatorClientError (Codensity IO) a)
-> Codensity IO a
-> ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO))
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Codensity IO a -> ExceptT FederatorClientError (Codensity IO) a
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT FederatorClientError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

headersFromTable :: HTTP2.TokenHeaderTable -> [HTTP.Header]
headersFromTable :: TokenHeaderTable -> [Header]
headersFromTable (TokenHeaderList
headerList, ValueTable
_) = ((TokenHeader -> Header) -> TokenHeaderList -> [Header])
-> TokenHeaderList -> (TokenHeader -> Header) -> [Header]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TokenHeader -> Header) -> TokenHeaderList -> [Header]
forall a b. (a -> b) -> [a] -> [b]
map TokenHeaderList
headerList ((TokenHeader -> Header) -> [Header])
-> (TokenHeader -> Header) -> [Header]
forall a b. (a -> b) -> a -> b
$ (Token -> HeaderName) -> TokenHeader -> Header
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Token -> HeaderName
HTTP2.tokenKey

-- This opens a new http2 connection. Using a http2-manager leads to this problem https://wearezeta.atlassian.net/browse/WPB-4787
-- FUTUREWORK: Replace with H2Manager.withHTTP2Request once the bugs are solved.
withNewHttpRequest :: H2Manager.Target -> HTTP2.Request -> (HTTP2.Response -> IO a) -> IO a
withNewHttpRequest :: forall a. Target -> Request -> (Response -> IO a) -> IO a
withNewHttpRequest Target
target Request
req Response -> IO a
k = do
  SSLContext
ctx <- IO SSLContext
SSL.context
  let cacheLimit :: Int
cacheLimit = Int
20
      sslRemoveTrailingDot :: Bool
sslRemoveTrailingDot = Bool
False
      tcpConnectionTimeout :: Int
tcpConnectionTimeout = Int
30_000_000
  MVar ConnectionAction
sendReqMVar <- IO (MVar ConnectionAction)
forall (m :: * -> *) a. MonadIO m => m (MVar a)
newEmptyMVar
  Async ()
thread <- IO (Async ()) -> IO (Async ())
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async ()) -> IO (Async ()))
-> (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ SSLContext
-> Target -> Int -> Bool -> Int -> MVar ConnectionAction -> IO ()
H2Manager.startPersistentHTTP2Connection SSLContext
ctx Target
target Int
cacheLimit Bool
sslRemoveTrailingDot Int
tcpConnectionTimeout MVar ConnectionAction
sendReqMVar
  let newConn :: HTTP2Conn
newConn = Async () -> IO () -> MVar ConnectionAction -> HTTP2Conn
H2Manager.HTTP2Conn Async ()
thread (MVar ConnectionAction -> ConnectionAction -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar MVar ConnectionAction
sendReqMVar ConnectionAction
H2Manager.CloseConnection) MVar ConnectionAction
sendReqMVar
  HTTP2Conn -> Request -> (Response -> IO a) -> IO a
forall r. HTTP2Conn -> Request -> (Response -> IO r) -> IO r
H2Manager.sendRequestWithConnection HTTP2Conn
newConn Request
req \Response
resp ->
    Response -> IO a
k Response
resp IO a -> IO () -> IO a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` HTTP2Conn
newConn.disconnect

performHTTP2Request ::
  Http2Manager ->
  H2Manager.Target ->
  HTTP2.Request ->
  IO (Either FederatorClientHTTP2Error (ResponseF Builder))
performHTTP2Request :: Http2Manager
-> Target
-> Request
-> IO (Either FederatorClientHTTP2Error (ResponseF Builder))
performHTTP2Request Http2Manager
_mgr Target
target Request
req = IO (ResponseF Builder)
-> IO (Either FederatorClientHTTP2Error (ResponseF Builder))
forall (m :: * -> *) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (IO (ResponseF Builder)
 -> IO (Either FederatorClientHTTP2Error (ResponseF Builder)))
-> IO (ResponseF Builder)
-> IO (Either FederatorClientHTTP2Error (ResponseF Builder))
forall a b. (a -> b) -> a -> b
$ do
  Target
-> Request
-> (Response -> IO (ResponseF Builder))
-> IO (ResponseF Builder)
forall a. Target -> Request -> (Response -> IO a) -> IO a
withNewHttpRequest Target
target Request
req ((Response -> IO (ResponseF Builder)) -> IO (ResponseF Builder))
-> (Response -> IO (ResponseF Builder)) -> IO (ResponseF Builder)
forall a b. (a -> b) -> a -> b
$ (StreamingResponse -> IO (ResponseF Builder))
-> Response -> IO (ResponseF Builder)
forall a. (StreamingResponse -> a) -> Response -> a
consumeStreamingResponseWith ((StreamingResponse -> IO (ResponseF Builder))
 -> Response -> IO (ResponseF Builder))
-> (StreamingResponse -> IO (ResponseF Builder))
-> Response
-> IO (ResponseF Builder)
forall a b. (a -> b) -> a -> b
$ \StreamingResponse
resp -> do
    [ByteString]
b <-
      (Either String [ByteString] -> [ByteString])
-> IO (Either String [ByteString]) -> IO [ByteString]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([ByteString] -> Either String [ByteString] -> [ByteString]
forall b a. b -> Either a b -> b
fromRight [ByteString]
forall a. Monoid a => a
mempty)
        (IO (Either String [ByteString]) -> IO [ByteString])
-> (StreamingResponse -> IO (Either String [ByteString]))
-> StreamingResponse
-> IO [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String IO [ByteString] -> IO (Either String [ByteString])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
        (ExceptT String IO [ByteString] -> IO (Either String [ByteString]))
-> (StreamingResponse -> ExceptT String IO [ByteString])
-> StreamingResponse
-> IO (Either String [ByteString])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceT IO ByteString -> ExceptT String IO [ByteString]
forall (m :: * -> *) a.
Monad m =>
SourceT m a -> ExceptT String m [a]
runSourceT
        (SourceT IO ByteString -> ExceptT String IO [ByteString])
-> (StreamingResponse -> SourceT IO ByteString)
-> StreamingResponse
-> ExceptT String IO [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamingResponse -> SourceT IO ByteString
forall a. ResponseF a -> a
responseBody
        (StreamingResponse -> IO [ByteString])
-> StreamingResponse -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ StreamingResponse
resp
    ResponseF Builder -> IO (ResponseF Builder)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResponseF Builder -> IO (ResponseF Builder))
-> ResponseF Builder -> IO (ResponseF Builder)
forall a b. (a -> b) -> a -> b
$ StreamingResponse
resp StreamingResponse -> Builder -> ResponseF Builder
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (ByteString -> Builder) -> [ByteString] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> Builder
byteString [ByteString]
b

consumeStreamingResponseWith :: (StreamingResponse -> a) -> HTTP2.Response -> a
consumeStreamingResponseWith :: forall a. (StreamingResponse -> a) -> Response -> a
consumeStreamingResponseWith StreamingResponse -> a
k Response
resp = do
  let headers :: [Header]
headers = TokenHeaderTable -> [Header]
headersFromTable (Response -> TokenHeaderTable
HTTP2.responseHeaders Response
resp)
      result :: SourceT IO ByteString
result = (ByteString -> Bool) -> IO ByteString -> SourceT IO ByteString
forall (m :: * -> *) a.
Functor m =>
(a -> Bool) -> m a -> SourceT m a
fromAction ByteString -> Bool
BS.null (IO ByteString -> SourceT IO ByteString)
-> IO ByteString -> SourceT IO ByteString
forall a b. (a -> b) -> a -> b
$ Response -> IO ByteString
HTTP2.getResponseBodyChunk Response
resp
  case Response -> Maybe Status
HTTP2.responseStatus Response
resp of
    Maybe Status
Nothing -> FederatorClientHTTP2Error -> a
forall a e. Exception e => e -> a
E.throw FederatorClientHTTP2Error
FederatorClientNoStatusCode
    Just Status
status ->
      StreamingResponse -> a
k
        Response
          { responseStatusCode :: Status
responseStatusCode = Status
status,
            responseHeaders :: Seq Header
responseHeaders = [Header] -> Seq Header
forall a. [a] -> Seq a
Seq.fromList [Header]
headers,
            responseHttpVersion :: HttpVersion
responseHttpVersion = HttpVersion
HTTP.http20,
            responseBody :: SourceT IO ByteString
responseBody = SourceT IO ByteString
result
          }

instance (KnownComponent c) => RunClient (FederatorClient c) where
  runRequestAcceptStatus :: Maybe [Status] -> Request -> FederatorClient c Response
runRequestAcceptStatus Maybe [Status]
expectedStatuses Request
req = do
    let successfulStatus :: Status -> Bool
successfulStatus Status
status =
          Bool -> ([Status] -> Bool) -> Maybe [Status] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (Status -> Bool
HTTP.statusIsSuccessful Status
status)
            (Status -> [Status] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Status
status)
            Maybe [Status]
expectedStatuses

    Maybe Version
v <- (FederatorClientVersionedEnv -> Maybe Version)
-> FederatorClient c (Maybe Version)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks FederatorClientVersionedEnv -> Maybe Version
cveVersion
    let vreq :: Request
vreq =
          Request
req
            { requestHeaders =
                ( versionHeader,
                  toByteString'
                    ( versionInt (fromMaybe V0 v)
                    )
                )
                  :<| requestHeaders req
            }

    (Status -> Bool)
-> Request
-> (StreamingResponse -> IO Response)
-> FederatorClient c Response
forall (c :: Component) a.
KnownComponent c =>
(Status -> Bool)
-> Request -> (StreamingResponse -> IO a) -> FederatorClient c a
withHTTP2StreamingRequest Status -> Bool
successfulStatus Request
vreq ((StreamingResponse -> IO Response) -> FederatorClient c Response)
-> (StreamingResponse -> IO Response) -> FederatorClient c Response
forall a b. (a -> b) -> a -> b
$ \StreamingResponse
resp -> do
      ByteString
bdy <-
        (Either String [ByteString] -> ByteString)
-> IO (Either String [ByteString]) -> IO ByteString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> ByteString)
-> ([ByteString] -> ByteString)
-> Either String [ByteString]
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> String -> ByteString
forall a b. a -> b -> a
const ByteString
forall a. Monoid a => a
mempty) (Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> ([ByteString] -> Builder) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Builder) -> [ByteString] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> Builder
byteString))
          (IO (Either String [ByteString]) -> IO ByteString)
-> (StreamingResponse -> IO (Either String [ByteString]))
-> StreamingResponse
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String IO [ByteString] -> IO (Either String [ByteString])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
          (ExceptT String IO [ByteString] -> IO (Either String [ByteString]))
-> (StreamingResponse -> ExceptT String IO [ByteString])
-> StreamingResponse
-> IO (Either String [ByteString])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceT IO ByteString -> ExceptT String IO [ByteString]
forall (m :: * -> *) a.
Monad m =>
SourceT m a -> ExceptT String m [a]
runSourceT
          (SourceT IO ByteString -> ExceptT String IO [ByteString])
-> (StreamingResponse -> SourceT IO ByteString)
-> StreamingResponse
-> ExceptT String IO [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamingResponse -> SourceT IO ByteString
forall a. ResponseF a -> a
responseBody
          (StreamingResponse -> IO ByteString)
-> StreamingResponse -> IO ByteString
forall a b. (a -> b) -> a -> b
$ StreamingResponse
resp
      Response -> IO Response
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> IO Response) -> Response -> IO Response
forall a b. (a -> b) -> a -> b
$ StreamingResponse
resp StreamingResponse -> ByteString -> Response
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ByteString
bdy

  throwClientError :: forall a. ClientError -> FederatorClient c a
throwClientError = FederatorClientError -> FederatorClient c a
forall a. FederatorClientError -> FederatorClient c a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FederatorClientError -> FederatorClient c a)
-> (ClientError -> FederatorClientError)
-> ClientError
-> FederatorClient c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientError -> FederatorClientError
FederatorClientServantError

instance (KnownComponent c) => RunStreamingClient (FederatorClient c) where
  withStreamingRequest :: forall a.
Request -> (StreamingResponse -> IO a) -> FederatorClient c a
withStreamingRequest = (Status -> Bool)
-> Request -> (StreamingResponse -> IO a) -> FederatorClient c a
forall (c :: Component) a.
KnownComponent c =>
(Status -> Bool)
-> Request -> (StreamingResponse -> IO a) -> FederatorClient c a
withHTTP2StreamingRequest Status -> Bool
HTTP.statusIsSuccessful

streamingResponseStrictBody :: StreamingResponse -> IO Builder
streamingResponseStrictBody :: StreamingResponse -> IO Builder
streamingResponseStrictBody =
  (Either String [ByteString] -> Builder)
-> IO (Either String [ByteString]) -> IO Builder
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Builder)
-> ([ByteString] -> Builder)
-> Either String [ByteString]
-> Builder
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Builder
stringUtf8 ((ByteString -> Builder) -> [ByteString] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ByteString -> Builder
byteString))
    (IO (Either String [ByteString]) -> IO Builder)
-> (StreamingResponse -> IO (Either String [ByteString]))
-> StreamingResponse
-> IO Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String IO [ByteString] -> IO (Either String [ByteString])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
    (ExceptT String IO [ByteString] -> IO (Either String [ByteString]))
-> (StreamingResponse -> ExceptT String IO [ByteString])
-> StreamingResponse
-> IO (Either String [ByteString])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceT IO ByteString -> ExceptT String IO [ByteString]
forall (m :: * -> *) a.
Monad m =>
SourceT m a -> ExceptT String m [a]
runSourceT
    (SourceT IO ByteString -> ExceptT String IO [ByteString])
-> (StreamingResponse -> SourceT IO ByteString)
-> StreamingResponse
-> ExceptT String IO [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamingResponse -> SourceT IO ByteString
forall a. ResponseF a -> a
responseBody

-- Perform a streaming request to the local federator.
withHTTP2StreamingRequest ::
  forall c a.
  (KnownComponent c) =>
  (HTTP.Status -> Bool) ->
  Request ->
  (StreamingResponse -> IO a) ->
  FederatorClient c a
withHTTP2StreamingRequest :: forall (c :: Component) a.
KnownComponent c =>
(Status -> Bool)
-> Request -> (StreamingResponse -> IO a) -> FederatorClient c a
withHTTP2StreamingRequest Status -> Bool
successfulStatus Request
req StreamingResponse -> IO a
handleResponse = do
  FederatorClientEnv
env <- (FederatorClientVersionedEnv -> FederatorClientEnv)
-> FederatorClient c FederatorClientEnv
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks FederatorClientVersionedEnv -> FederatorClientEnv
cveEnv
  let baseUrlPath :: Builder
baseUrlPath =
        [Text] -> Builder
HTTP.encodePathSegments
          [ Text
Item [Text]
"rpc",
            Domain -> Text
domainText (FederatorClientEnv -> Domain
ceTargetDomain FederatorClientEnv
env),
            Component -> Text
componentName (forall (c :: Component). KnownComponent c => Component
componentVal @c)
          ]
  let path :: Builder
path = Builder
baseUrlPath Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Request -> Builder
forall body path. RequestF body path -> path
requestPath Request
req

  ByteString
body <- do
    case Request -> Maybe (RequestBody, MediaType)
forall body path. RequestF body path -> Maybe (body, MediaType)
requestBody Request
req of
      Just (RequestBodyLBS ByteString
lbs, MediaType
_) -> ByteString -> FederatorClient c ByteString
forall a. a -> FederatorClient c a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
lbs
      Just (RequestBodyBS ByteString
bs, MediaType
_) -> ByteString -> FederatorClient c ByteString
forall a. a -> FederatorClient c a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> ByteString
LBS.fromStrict ByteString
bs)
      Just (RequestBodySource SourceIO ByteString
_, MediaType
_) -> FederatorClientError -> FederatorClient c ByteString
forall a. FederatorClientError -> FederatorClient c a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError FederatorClientError
FederatorClientStreamingNotSupported
      Maybe (RequestBody, MediaType)
Nothing -> ByteString -> FederatorClient c ByteString
forall a. a -> FederatorClient c a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
forall a. Monoid a => a
mempty
  let headers :: [Header]
headers =
        Seq Header -> [Header]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Request -> Seq Header
forall body path. RequestF body path -> Seq Header
requestHeaders Request
req)
          [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [(HeaderName
forall a. IsString a => a
originDomainHeaderName, Domain -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' (FederatorClientEnv -> Domain
ceOriginDomain FederatorClientEnv
env))]
          [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [(HeaderName
HTTP.hAccept, [MediaType] -> ByteString
forall h. RenderHeader h => h -> ByteString
HTTP.renderHeader (Seq MediaType -> [MediaType]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq MediaType -> [MediaType]) -> Seq MediaType -> [MediaType]
forall a b. (a -> b) -> a -> b
$ Request
req.requestAccept))]
          [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [(HeaderName
"Wire-Origin-Request-Id", RequestId -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' (RequestId -> ByteString) -> RequestId -> ByteString
forall a b. (a -> b) -> a -> b
$ FederatorClientEnv -> RequestId
ceOriginRequestId FederatorClientEnv
env)]
      req' :: Request
req' =
        ByteString -> ByteString -> [Header] -> Builder -> Request
HTTP2.requestBuilder
          (Request -> ByteString
forall body path. RequestF body path -> ByteString
requestMethod Request
req)
          (ByteString -> ByteString
LBS.toStrict (Builder -> ByteString
toLazyByteString Builder
path))
          [Header]
headers
          (ByteString -> Builder
lazyByteString ByteString
body)
  let Endpoint (Text -> ByteString
Text.encodeUtf8 -> ByteString
hostname) (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Int
port) = FederatorClientEnv -> Endpoint
ceFederator FederatorClientEnv
env
  StreamingResponse
resp <-
    (FederatorClientError -> FederatorClient c StreamingResponse)
-> (StreamingResponse -> FederatorClient c StreamingResponse)
-> Either FederatorClientError StreamingResponse
-> FederatorClient c StreamingResponse
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FederatorClientError -> FederatorClient c StreamingResponse
forall a. FederatorClientError -> FederatorClient c a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StreamingResponse -> FederatorClient c StreamingResponse
forall a. a -> FederatorClient c a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Either FederatorClientError StreamingResponse
 -> FederatorClient c StreamingResponse)
-> (Codensity IO (Either FederatorClientError StreamingResponse)
    -> FederatorClient
         c (Either FederatorClientError StreamingResponse))
-> Codensity IO (Either FederatorClientError StreamingResponse)
-> FederatorClient c StreamingResponse
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Codensity IO (Either FederatorClientError StreamingResponse)
-> FederatorClient
     c (Either FederatorClientError StreamingResponse)
forall a (c :: Component). Codensity IO a -> FederatorClient c a
liftCodensity
      (Codensity IO (Either FederatorClientError StreamingResponse)
 -> FederatorClient c StreamingResponse)
-> Codensity IO (Either FederatorClientError StreamingResponse)
-> FederatorClient c StreamingResponse
forall a b. (a -> b) -> a -> b
$ (forall b.
 (Either FederatorClientError StreamingResponse -> IO b) -> IO b)
-> Codensity IO (Either FederatorClientError StreamingResponse)
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity
      ((forall b.
  (Either FederatorClientError StreamingResponse -> IO b) -> IO b)
 -> Codensity IO (Either FederatorClientError StreamingResponse))
-> (forall b.
    (Either FederatorClientError StreamingResponse -> IO b) -> IO b)
-> Codensity IO (Either FederatorClientError StreamingResponse)
forall a b. (a -> b) -> a -> b
$ \Either FederatorClientError StreamingResponse -> IO b
k ->
        IO b -> [Handler b] -> IO b
forall a. IO a -> [Handler a] -> IO a
E.catches
          (Target -> Request -> (Response -> IO b) -> IO b
forall a. Target -> Request -> (Response -> IO a) -> IO a
withNewHttpRequest (Bool
False, ByteString
hostname, Int
port) Request
req' ((StreamingResponse -> IO b) -> Response -> IO b
forall a. (StreamingResponse -> a) -> Response -> a
consumeStreamingResponseWith (Either FederatorClientError StreamingResponse -> IO b
k (Either FederatorClientError StreamingResponse -> IO b)
-> (StreamingResponse
    -> Either FederatorClientError StreamingResponse)
-> StreamingResponse
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamingResponse -> Either FederatorClientError StreamingResponse
forall a b. b -> Either a b
Right)))
          [ (FederatorClientHTTP2Error -> IO b) -> Handler b
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler ((FederatorClientHTTP2Error -> IO b) -> Handler b)
-> (FederatorClientHTTP2Error -> IO b) -> Handler b
forall a b. (a -> b) -> a -> b
$ Either FederatorClientError StreamingResponse -> IO b
k (Either FederatorClientError StreamingResponse -> IO b)
-> (FederatorClientHTTP2Error
    -> Either FederatorClientError StreamingResponse)
-> FederatorClientHTTP2Error
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederatorClientError
-> Either FederatorClientError StreamingResponse
forall a b. a -> Either a b
Left (FederatorClientError
 -> Either FederatorClientError StreamingResponse)
-> (FederatorClientHTTP2Error -> FederatorClientError)
-> FederatorClientHTTP2Error
-> Either FederatorClientError StreamingResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederatorClientHTTP2Error -> FederatorClientError
FederatorClientHTTP2Error,
            (IOException -> IO b) -> Handler b
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler ((IOException -> IO b) -> Handler b)
-> (IOException -> IO b) -> Handler b
forall a b. (a -> b) -> a -> b
$ Either FederatorClientError StreamingResponse -> IO b
k (Either FederatorClientError StreamingResponse -> IO b)
-> (IOException -> Either FederatorClientError StreamingResponse)
-> IOException
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederatorClientError
-> Either FederatorClientError StreamingResponse
forall a b. a -> Either a b
Left (FederatorClientError
 -> Either FederatorClientError StreamingResponse)
-> (IOException -> FederatorClientError)
-> IOException
-> Either FederatorClientError StreamingResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederatorClientHTTP2Error -> FederatorClientError
FederatorClientHTTP2Error (FederatorClientHTTP2Error -> FederatorClientError)
-> (IOException -> FederatorClientHTTP2Error)
-> IOException
-> FederatorClientError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> FederatorClientHTTP2Error
FederatorClientConnectionError,
            (HTTP2Error -> IO b) -> Handler b
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler ((HTTP2Error -> IO b) -> Handler b)
-> (HTTP2Error -> IO b) -> Handler b
forall a b. (a -> b) -> a -> b
$ Either FederatorClientError StreamingResponse -> IO b
k (Either FederatorClientError StreamingResponse -> IO b)
-> (HTTP2Error -> Either FederatorClientError StreamingResponse)
-> HTTP2Error
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederatorClientError
-> Either FederatorClientError StreamingResponse
forall a b. a -> Either a b
Left (FederatorClientError
 -> Either FederatorClientError StreamingResponse)
-> (HTTP2Error -> FederatorClientError)
-> HTTP2Error
-> Either FederatorClientError StreamingResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederatorClientHTTP2Error -> FederatorClientError
FederatorClientHTTP2Error (FederatorClientHTTP2Error -> FederatorClientError)
-> (HTTP2Error -> FederatorClientHTTP2Error)
-> HTTP2Error
-> FederatorClientError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HTTP2Error -> FederatorClientHTTP2Error
FederatorClientHTTP2Exception,
            (SomeSSLException -> IO b) -> Handler b
forall a e. Exception e => (e -> IO a) -> Handler a
E.Handler ((SomeSSLException -> IO b) -> Handler b)
-> (SomeSSLException -> IO b) -> Handler b
forall a b. (a -> b) -> a -> b
$ Either FederatorClientError StreamingResponse -> IO b
k (Either FederatorClientError StreamingResponse -> IO b)
-> (SomeSSLException
    -> Either FederatorClientError StreamingResponse)
-> SomeSSLException
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederatorClientError
-> Either FederatorClientError StreamingResponse
forall a b. a -> Either a b
Left (FederatorClientError
 -> Either FederatorClientError StreamingResponse)
-> (SomeSSLException -> FederatorClientError)
-> SomeSSLException
-> Either FederatorClientError StreamingResponse
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederatorClientHTTP2Error -> FederatorClientError
FederatorClientHTTP2Error (FederatorClientHTTP2Error -> FederatorClientError)
-> (SomeSSLException -> FederatorClientHTTP2Error)
-> SomeSSLException
-> FederatorClientError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeSSLException -> FederatorClientHTTP2Error
FederatorClientTLSException
          ]
  if Status -> Bool
successfulStatus (StreamingResponse -> Status
forall a. ResponseF a -> Status
responseStatusCode StreamingResponse
resp)
    then IO a -> FederatorClient c a
forall a. IO a -> FederatorClient c a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> FederatorClient c a) -> IO a -> FederatorClient c a
forall a b. (a -> b) -> a -> b
$ StreamingResponse -> IO a
handleResponse StreamingResponse
resp
    else do
      -- in case of an error status code, read the whole body to construct the error
      Builder
bdy <- IO Builder -> FederatorClient c Builder
forall a. IO a -> FederatorClient c a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Builder -> FederatorClient c Builder)
-> IO Builder -> FederatorClient c Builder
forall a b. (a -> b) -> a -> b
$ StreamingResponse -> IO Builder
streamingResponseStrictBody StreamingResponse
resp
      FederatorClientError -> FederatorClient c a
forall a. FederatorClientError -> FederatorClient c a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (FederatorClientError -> FederatorClient c a)
-> FederatorClientError -> FederatorClient c a
forall a b. (a -> b) -> a -> b
$
        Error -> FederatorClientError
FederatorClientError
          ( Status -> Domain -> ByteString -> ByteString -> Error
mkFailureResponse
              (StreamingResponse -> Status
forall a. ResponseF a -> Status
responseStatusCode StreamingResponse
resp)
              (FederatorClientEnv -> Domain
ceTargetDomain FederatorClientEnv
env)
              (Builder -> ByteString
toLazyByteString (Request -> Builder
forall body path. RequestF body path -> path
requestPath Request
req))
              (Builder -> ByteString
toLazyByteString Builder
bdy)
          )

mkFailureResponse :: HTTP.Status -> Domain -> LByteString -> LByteString -> Wai.Error
mkFailureResponse :: Status -> Domain -> ByteString -> ByteString -> Error
mkFailureResponse Status
status Domain
domain ByteString
path ByteString
body
  -- If the outward federator fails with 403, that means that there was an
  -- error at the level of the local federator (most likely due to a bug somewhere
  -- in wire-server). It does not make sense to return this error directly to the
  -- client, since it is always due to a server issue, so we map it to a 500
  -- error.
  | Status -> Int
HTTP.statusCode Status
status Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
403 =
      Status -> LText -> LText -> Error
Wai.mkError
        Status
HTTP.status500
        LText
"federation-local-error"
        ( LText
"Local federator failure: "
            LText -> LText -> LText
forall a. Semigroup a => a -> a -> a
<> OnDecodeError -> ByteString -> LText
LText.decodeUtf8With OnDecodeError
Text.lenientDecode ByteString
body
        )
  -- Any other error is interpreted as a correctly formatted wai error, and
  -- returned to the client.
  | Bool
otherwise =
      (Error -> Maybe Error -> Error
forall a. a -> Maybe a -> a
fromMaybe Error
defaultError (ByteString -> Maybe Error
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
body))
        { Wai.errorData =
            Just
              Wai.FederationErrorData
                { Wai.federrDomain = domain,
                  Wai.federrPath =
                    "/federation"
                      <> Text.decodeUtf8With Text.lenientDecode (LBS.toStrict path)
                }
        }
  where
    defaultError :: Error
defaultError =
      Status -> LText -> LText -> Error
Wai.mkError
        Status
status
        LText
"unknown-federation-error"
        (OnDecodeError -> ByteString -> LText
LText.decodeUtf8With OnDecodeError
Text.lenientDecode ByteString
body)

-- | Run federator client synchronously.
runFederatorClient ::
  FederatorClientEnv ->
  FederatorClient c a ->
  IO (Either FederatorClientError a)
runFederatorClient :: forall (c :: Component) a.
FederatorClientEnv
-> FederatorClient c a -> IO (Either FederatorClientError a)
runFederatorClient FederatorClientEnv
env =
  Codensity IO (Either FederatorClientError a)
-> IO (Either FederatorClientError a)
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity
    (Codensity IO (Either FederatorClientError a)
 -> IO (Either FederatorClientError a))
-> (FederatorClient c a
    -> Codensity IO (Either FederatorClientError a))
-> FederatorClient c a
-> IO (Either FederatorClientError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederatorClientEnv
-> FederatorClient c a
-> Codensity IO (Either FederatorClientError a)
forall (c :: Component) a.
FederatorClientEnv
-> FederatorClient c a
-> Codensity IO (Either FederatorClientError a)
runFederatorClientToCodensity FederatorClientEnv
env

runVersionedFederatorClient ::
  FederatorClientVersionedEnv ->
  FederatorClient c a ->
  IO (Either FederatorClientError a)
runVersionedFederatorClient :: forall (c :: Component) a.
FederatorClientVersionedEnv
-> FederatorClient c a -> IO (Either FederatorClientError a)
runVersionedFederatorClient FederatorClientVersionedEnv
venv =
  Codensity IO (Either FederatorClientError a)
-> IO (Either FederatorClientError a)
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity
    (Codensity IO (Either FederatorClientError a)
 -> IO (Either FederatorClientError a))
-> (FederatorClient c a
    -> Codensity IO (Either FederatorClientError a))
-> FederatorClient c a
-> IO (Either FederatorClientError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT FederatorClientError (Codensity IO) a
-> Codensity IO (Either FederatorClientError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
    (ExceptT FederatorClientError (Codensity IO) a
 -> Codensity IO (Either FederatorClientError a))
-> (FederatorClient c a
    -> ExceptT FederatorClientError (Codensity IO) a)
-> FederatorClient c a
-> Codensity IO (Either FederatorClientError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederatorClientVersionedEnv
-> FederatorClient c a
-> ExceptT FederatorClientError (Codensity IO) a
forall (c :: Component) a.
FederatorClientVersionedEnv
-> FederatorClient c a
-> ExceptT FederatorClientError (Codensity IO) a
runVersionedFederatorClientToCodensity FederatorClientVersionedEnv
venv

runFederatorClientToCodensity ::
  forall c a.
  FederatorClientEnv ->
  FederatorClient c a ->
  Codensity IO (Either FederatorClientError a)
runFederatorClientToCodensity :: forall (c :: Component) a.
FederatorClientEnv
-> FederatorClient c a
-> Codensity IO (Either FederatorClientError a)
runFederatorClientToCodensity FederatorClientEnv
env FederatorClient c a
action = ExceptT FederatorClientError (Codensity IO) a
-> Codensity IO (Either FederatorClientError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT FederatorClientError (Codensity IO) a
 -> Codensity IO (Either FederatorClientError a))
-> ExceptT FederatorClientError (Codensity IO) a
-> Codensity IO (Either FederatorClientError a)
forall a b. (a -> b) -> a -> b
$ do
  Version
v <-
    FederatorClientVersionedEnv
-> FederatorClient 'Brig Version
-> ExceptT FederatorClientError (Codensity IO) Version
forall (c :: Component) a.
FederatorClientVersionedEnv
-> FederatorClient c a
-> ExceptT FederatorClientError (Codensity IO) a
runVersionedFederatorClientToCodensity
      (FederatorClientEnv -> Maybe Version -> FederatorClientVersionedEnv
FederatorClientVersionedEnv FederatorClientEnv
env Maybe Version
forall a. Maybe a
Nothing)
      (Set Version -> FederatorClient 'Brig Version
versionNegotiation Set Version
supportedVersions)
  forall (c :: Component) a.
FederatorClientVersionedEnv
-> FederatorClient c a
-> ExceptT FederatorClientError (Codensity IO) a
runVersionedFederatorClientToCodensity @c
    (FederatorClientEnv -> Maybe Version -> FederatorClientVersionedEnv
FederatorClientVersionedEnv FederatorClientEnv
env (Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v))
    FederatorClient c a
action

runVersionedFederatorClientToCodensity ::
  FederatorClientVersionedEnv ->
  FederatorClient c a ->
  ExceptT FederatorClientError (Codensity IO) a
runVersionedFederatorClientToCodensity :: forall (c :: Component) a.
FederatorClientVersionedEnv
-> FederatorClient c a
-> ExceptT FederatorClientError (Codensity IO) a
runVersionedFederatorClientToCodensity FederatorClientVersionedEnv
env =
  (ReaderT
   FederatorClientVersionedEnv
   (ExceptT FederatorClientError (Codensity IO))
   a
 -> FederatorClientVersionedEnv
 -> ExceptT FederatorClientError (Codensity IO) a)
-> FederatorClientVersionedEnv
-> ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO))
     a
-> ExceptT FederatorClientError (Codensity IO) a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  FederatorClientVersionedEnv
  (ExceptT FederatorClientError (Codensity IO))
  a
-> FederatorClientVersionedEnv
-> ExceptT FederatorClientError (Codensity IO) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT FederatorClientVersionedEnv
env
    (ReaderT
   FederatorClientVersionedEnv
   (ExceptT FederatorClientError (Codensity IO))
   a
 -> ExceptT FederatorClientError (Codensity IO) a)
-> (FederatorClient c a
    -> ReaderT
         FederatorClientVersionedEnv
         (ExceptT FederatorClientError (Codensity IO))
         a)
-> FederatorClient c a
-> ExceptT FederatorClientError (Codensity IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT
  FederatorClientVersionedEnv
  (ExceptT FederatorClientError (Codensity IO))
  (Maybe a)
-> ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO))
     a
forall {b}.
ReaderT
  FederatorClientVersionedEnv
  (ExceptT FederatorClientError (Codensity IO))
  (Maybe b)
-> ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO))
     b
unmaybe
    (ReaderT
   FederatorClientVersionedEnv
   (ExceptT FederatorClientError (Codensity IO))
   (Maybe a)
 -> ReaderT
      FederatorClientVersionedEnv
      (ExceptT FederatorClientError (Codensity IO))
      a)
-> (FederatorClient c a
    -> ReaderT
         FederatorClientVersionedEnv
         (ExceptT FederatorClientError (Codensity IO))
         (Maybe a))
-> FederatorClient c a
-> ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO))
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT
  (ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO)))
  a
-> ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO))
     (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
    (MaybeT
   (ReaderT
      FederatorClientVersionedEnv
      (ExceptT FederatorClientError (Codensity IO)))
   a
 -> ReaderT
      FederatorClientVersionedEnv
      (ExceptT FederatorClientError (Codensity IO))
      (Maybe a))
-> (FederatorClient c a
    -> MaybeT
         (ReaderT
            FederatorClientVersionedEnv
            (ExceptT FederatorClientError (Codensity IO)))
         a)
-> FederatorClient c a
-> ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO))
     (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FederatorClient c a
-> MaybeT
     (ReaderT
        FederatorClientVersionedEnv
        (ExceptT FederatorClientError (Codensity IO)))
     a
forall (c :: Component) a.
FederatorClient c a
-> MaybeT
     (ReaderT
        FederatorClientVersionedEnv
        (ExceptT FederatorClientError (Codensity IO)))
     a
unFederatorClient
  where
    unmaybe :: ReaderT
  FederatorClientVersionedEnv
  (ExceptT FederatorClientError (Codensity IO))
  (Maybe b)
-> ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO))
     b
unmaybe = (ReaderT
  FederatorClientVersionedEnv
  (ExceptT FederatorClientError (Codensity IO))
  b
-> (b
    -> ReaderT
         FederatorClientVersionedEnv
         (ExceptT FederatorClientError (Codensity IO))
         b)
-> Maybe b
-> ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO))
     b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FederatorClientError
-> ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO))
     b
forall a e. Exception e => e -> a
E.throw FederatorClientError
FederatorClientVersionMismatch) b
-> ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO))
     b
forall a.
a
-> ReaderT
     FederatorClientVersionedEnv
     (ExceptT FederatorClientError (Codensity IO))
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure =<<)

versionNegotiation :: Set Version -> FederatorClient 'Brig Version
versionNegotiation :: Set Version -> FederatorClient 'Brig Version
versionNegotiation Set Version
localVersions =
  let req :: Request
req =
        Request
defaultRequest
          { requestPath = "/api-version",
            requestBody = Just (RequestBodyLBS (Aeson.encode ()), "application" HTTP.// "json"),
            requestHeaders = [],
            requestMethod = HTTP.methodPost
          }
   in forall (c :: Component) a.
KnownComponent c =>
(Status -> Bool)
-> Request -> (StreamingResponse -> IO a) -> FederatorClient c a
withHTTP2StreamingRequest @'Brig Status -> Bool
HTTP.statusIsSuccessful Request
req ((StreamingResponse -> IO Version)
 -> FederatorClient 'Brig Version)
-> (StreamingResponse -> IO Version)
-> FederatorClient 'Brig Version
forall a b. (a -> b) -> a -> b
$ \StreamingResponse
resp -> do
        ByteString
body <- Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> IO Builder -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StreamingResponse -> IO Builder
streamingResponseStrictBody StreamingResponse
resp
        [Int]
allRemoteVersions <- case ByteString -> Maybe VersionInfo
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode ByteString
body of
          Maybe VersionInfo
Nothing -> FederatorClientError -> IO [Int]
forall a e. Exception e => e -> a
E.throw (VersionNegotiationError -> FederatorClientError
FederatorClientVersionNegotiationError VersionNegotiationError
InvalidVersionInfo)
          Just VersionInfo
info -> [Int] -> IO [Int]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VersionInfo -> [Int]
vinfoSupported VersionInfo
info)
        -- ignore versions that don't even exist locally
        let remoteVersions :: Set Version
remoteVersions = [Version] -> Set Version
forall a. Ord a => [a] -> Set a
Set.fromList ([Version] -> Set Version) -> [Version] -> Set Version
forall a b. (a -> b) -> a -> b
$ (Int -> Maybe Version) -> [Int] -> [Version]
forall a b. (a -> Maybe b) -> [a] -> [b]
Imports.mapMaybe Int -> Maybe Version
intToVersion [Int]
allRemoteVersions
        case Set Version -> Maybe Version
forall a. Set a -> Maybe a
Set.lookupMax (Set Version -> Set Version -> Set Version
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set Version
remoteVersions Set Version
localVersions) of
          Just Version
v -> Version -> IO Version
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Version
v
          Maybe Version
Nothing ->
            FederatorClientError -> IO Version
forall a e. Exception e => e -> a
E.throw
              (FederatorClientError -> IO Version)
-> (VersionNegotiationError -> FederatorClientError)
-> VersionNegotiationError
-> IO Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionNegotiationError -> FederatorClientError
FederatorClientVersionNegotiationError
              (VersionNegotiationError -> IO Version)
-> VersionNegotiationError -> IO Version
forall a b. (a -> b) -> a -> b
$ if Set Version -> Maybe Version
forall a. Set a -> Maybe a
Set.lookupMax Set Version
localVersions Maybe Version -> Maybe Version -> Bool
forall a. Ord a => a -> a -> Bool
> Set Version -> Maybe Version
forall a. Set a -> Maybe a
Set.lookupMax Set Version
remoteVersions
                then VersionNegotiationError
RemoteTooOld
                else VersionNegotiationError
RemoteTooNew