{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedLists #-}
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
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]
(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
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
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
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
| 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
)
| 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)
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)
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